home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1995 August: Tool Chest / Dev.CD Aug 95 TC / Dev.CD Aug 95 TC.toast / Tool Chest / Development Tools & Languages / Dylan Related / Thomas / MacGambit⁄Thomas / MacGambit⁄Thomas Sources / Compiler (.scm) / front.scm < prev    next >
Encoding:
Text File  |  1995-03-15  |  73.9 KB  |  2,172 lines  |  [TEXT/gamI]
  1. ;==============================================================================
  2.  
  3. ; file: "front.scm"
  4.  
  5. ;------------------------------------------------------------------------------
  6. ;
  7. ; Front-end of GAMBIT compiler
  8. ;
  9. ;------------------------------------------------------------------------------
  10.  
  11. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  12. ;
  13. ; The file compiler:
  14. ; -----------------
  15.  
  16. ; sample use:
  17. ;
  18. ; (cf "tak" 'M68000)              -- compile 'tak.scm' for M68000 target
  19. ; (cf "tak" 'M68000 'VERBOSE)     -- produce compiler trace
  20. ; (cf "tak" 'M68000 'REPORT)      -- show usage of global variables
  21. ; (cf "tak" 'M68000 'PVM)         -- write PVM code on 'tak.pvm'
  22. ; (cf "tak" 'M68000 'DEBUG)       -- generate code with debugging info
  23. ; (cf "tak" 'M68000 'EXPANSION)   -- show code after source-to-source transform
  24. ; (cf "tak" 'M68000 'ASM 'STATS)  -- various back-end options
  25.  
  26. (define (cf source target-name . opts)
  27.  
  28.   (let ((module-name (file-name (file-root source)))
  29.         (info-port (if (memq 'VERBOSE opts) (current-output-port) #f))
  30.         (program 
  31.           (append (list BEGIN-sym)
  32.                   program-prefix
  33.                   (list (list **INCLUDE-sym source))
  34.                   program-suffix)))
  35.  
  36.     (let ((result (compile-program program
  37.                                    target-name
  38.                                    opts
  39.                                    module-name
  40.                                    (file-root source)
  41.                                    info-port)))
  42.  
  43.       (if (and info-port (not (eq? info-port (current-output-port))))
  44.         (close-output-port info-port))
  45.  
  46.       result)))
  47.  
  48. (define program-prefix #f)
  49. (set! program-prefix '())
  50.  
  51. (define program-suffix #f)
  52. (set! program-suffix '())
  53.  
  54. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  55. ;
  56. ; The expression compiler:
  57. ; -----------------------
  58.  
  59. ; sample use:
  60. ;
  61. ; (ce '(+ 2 3) 'M68000)  -- compile the expression (+ 2 3)
  62.  
  63. (define (ce expr target-name . opts)
  64.  
  65.   (let ((info-port (if (memq 'VERBOSE opts) (current-output-port) #f)))
  66.  
  67.     (let ((result (compile-program expr
  68.                                    target-name
  69.                                    opts
  70.                                    "#"
  71.                                    "#"
  72.                                    info-port)))
  73.  
  74.       (if (and info-port (not (eq? info-port (current-output-port))))
  75.         (close-output-port info-port))
  76.  
  77.       result)))
  78.  
  79. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  80. ;
  81. ; The program compiler:
  82. ; --------------------
  83.  
  84. (define (compile-program program target-name opts module-name dest info-port)
  85.  
  86.   (define (compiler-body)
  87.  
  88.     (scheme-global-var-set!
  89.       (scheme-global-var (string->canonical-symbol "##COMPILATION-OPTIONS"))
  90.       opts)
  91.  
  92.     (ptree.begin! info-port)
  93.     (virtual.begin!)
  94.     (select-target! target-name info-port)
  95.  
  96.     (parse-program
  97.       (list (expression->source program #f))
  98.       (make-global-environment)
  99.       (lambda (lst env)
  100.  
  101.         (let ((parsed-program
  102.                 (map (lambda (x) (normalize-parse-tree (car x) (cdr x))) lst)))
  103.  
  104.           (if (memq 'EXPANSION opts)
  105.             (let ((port (current-output-port)))
  106.               (display "Expansion:" port)
  107.               (newline port)
  108.               (let loop ((l parsed-program))
  109.                 (if (pair? l)
  110.                   (let ((ptree (car l)))
  111.                     (pp-expression (parse-tree->expression ptree) port)
  112.                     (loop (cdr l)))))
  113.               (newline port)))
  114.  
  115.           (let ((module-init-proc
  116.                   (compile-parsed-program module-name parsed-program env info-port)))
  117.  
  118.             (if (memq 'REPORT opts)
  119.               (generate-report env))
  120.  
  121.             (if (memq 'PVM opts)
  122.               (let ((pvm-port (open-output-file (string-append dest ".pvm"))))
  123.                 (virtual.dump module-init-proc pvm-port)
  124.                 (close-output-port pvm-port)))
  125.  
  126.             (target.dump module-init-proc dest opts)))))
  127.  
  128.     (unselect-target!)
  129.     (virtual.end!)
  130.     (ptree.end!)
  131.  
  132.     #t)
  133.  
  134.   (let ((successful (with-exception-handling compiler-body)))
  135.  
  136.     (if info-port
  137.       (if successful
  138.         (begin
  139.           (display "Compilation finished." info-port)
  140.           (newline info-port))
  141.         (begin
  142.           (display "Compilation terminated abnormally." info-port)
  143.           (newline info-port))))
  144.  
  145.     successful))
  146.  
  147. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  148. ;
  149. ; Report generation:
  150.  
  151. (define (generate-report env)
  152.   (let ((vars (sort-list (env-global-variables env)
  153.                          (lambda (x y)
  154.                            (string<? (symbol->string (var-name x))
  155.                                      (symbol->string (var-name y))))))
  156.         (decl (env-declarations env)))
  157.  
  158.     (define (report title pred? vars wrote-something?)
  159.       (if (pair? vars)
  160.         (let ((var (car vars)))
  161.           (if (pred? var)
  162.             (begin
  163.               (if (not wrote-something?)
  164.                 (begin
  165.                   (display " ")
  166.                   (display title)
  167.                   (newline)))
  168.               (let loop1 ((l (var-refs var)) (r? #f) (c? #f))
  169.                 (if (pair? l)
  170.                   (let* ((x (car l))
  171.                          (y (node-parent x)))
  172.                     (if (and y (app? y) (eq? x (app-oper y)))
  173.                       (loop1 (cdr l) r? #t)
  174.                       (loop1 (cdr l) #t c?)))
  175.                   (let loop2 ((l (var-sets var)) (d? #f) (a? #f))
  176.                     (if (pair? l)
  177.                       (if (set? (car l))
  178.                         (loop2 (cdr l) d? #t)
  179.                         (loop2 (cdr l) #t a?))
  180.                       (begin
  181.                         (display "  [")
  182.                         (if d? (display "D") (display " "))
  183.                         (if a? (display "A") (display " "))
  184.                         (if r? (display "R") (display " "))
  185.                         (if c? (display "C") (display " "))
  186.                         (display "] ")
  187.                         (display (var-name var)) (newline))))))
  188.               (report title pred? (cdr vars) #t))
  189.             (cons (car vars) (report title pred? (cdr vars) wrote-something?))))
  190.         (begin
  191.           (if wrote-something? (newline))
  192.           '())))
  193.  
  194.     (display "Global variable usage:") (newline)
  195.     (newline)
  196.  
  197.     (report "OTHERS"
  198.             (lambda (x) #t)
  199.             (report "EXTENDED"
  200.                     (lambda (x) (target.prim-info (var-name x)))
  201.                     (report "STANDARD"
  202.                             (lambda (x) (standard-procedure (var-name x) decl))
  203.                             vars
  204.                             #f)
  205.                     #f)
  206.             #f)))
  207.  
  208. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  209.  
  210. (define (compile-parsed-program module-name program env info-port)
  211.  
  212.   (if info-port
  213.     (display "Compiling:" info-port))
  214.  
  215.   (set! trace-indentation 0)
  216.  
  217.   (set! *bbs* (make-bbs))
  218.   (set! *global-env* env)
  219.  
  220.   (set! proc-tree '())
  221.   (set! proc-queue '())
  222.   (set! constant-vars '())
  223.   (set! known-procs '())
  224.  
  225.   (restore-context
  226.     (make-context 0 '() (list ret-var) '() (entry-interrupt) #f))
  227.  
  228.   (let* ((entry-lbl (bbs-new-lbl! *bbs*))
  229.          (body-lbl (bbs-new-lbl! *bbs*))
  230.          (frame (current-frame ret-var-set)))
  231.  
  232.     (bbs-entry-lbl-num-set! *bbs* entry-lbl)
  233.  
  234.     (set! entry-bb
  235.       (make-bb (make-LABEL-PROC entry-lbl 0 0 #f #f frame #f)
  236.                *bbs*))
  237.  
  238.     (bb-put-branch! entry-bb
  239.       (make-JUMP (make-lbl body-lbl) #f #f frame #f))
  240.  
  241.     (set! *bb*
  242.       (make-bb (make-LABEL-SIMP body-lbl frame #f)
  243.                *bbs*))
  244.  
  245.     (let loop1 ((l program))
  246.       (if (not (null? l))
  247.         (let ((node (car l)))
  248.           (if (def? node)
  249.             (let* ((var (def-var node))
  250.                    (val (global-val var)))
  251.               (if (and val (prc? val))
  252.                 (add-constant-var var
  253.                   (make-obj
  254.                     (make-proc-obj
  255.                       (symbol->string (var-name var)) ; name
  256.                       #t                 ; primitive?
  257.                       #f                 ; code
  258.                       (call-pattern val) ; call-pat
  259.                       #t                 ; side-effects?
  260.                       '()                ; strict-pat
  261.                       '(#f)))))))        ; type
  262.           (loop1 (cdr l)))))
  263.  
  264.     (let loop2 ((l program))
  265.       (if (null? l)
  266.  
  267.         (let ((ret-opnd (var->opnd ret-var)))
  268.           (seal-bb #t 'RETURN)
  269.           (dealloc-slots nb-slots)
  270.           (bb-put-branch! *bb*
  271.             (make-JUMP ret-opnd #f #f (current-frame (set-empty)) #f)))
  272.  
  273.         (let ((node (car l)))
  274.           (if (def? node)
  275.  
  276.             (begin
  277.               (gen-define (def-var node) (def-val node) info-port)
  278.               (loop2 (cdr l)))
  279.  
  280.             (if (null? (cdr l))
  281.               (gen-node node ret-var-set 'tail)
  282.               (begin
  283.                 (gen-node node ret-var-set 'need)
  284.                 (loop2 (cdr l))))))))
  285.  
  286.     (let loop ()
  287.       (if (pair? proc-queue)
  288.         (let ((x (car proc-queue)))
  289.           (set! proc-queue (cdr proc-queue))
  290.           (gen-proc (car x) (cadr x) (caddr x) info-port)
  291.           (trace-unindent info-port)
  292.           (loop))))
  293.  
  294.     (if info-port
  295.       (begin
  296.         (newline info-port)
  297.         (newline info-port)))
  298.  
  299.     (bbs-purify! *bbs*)
  300.  
  301.     (let ((proc
  302.             (make-proc-obj
  303.               (string-append "###" module-name)   ; name
  304.               #t            ; primitive?
  305.               *bbs*         ; code
  306.               '(0)          ; call-pat
  307.               #t            ; side-effects?
  308.               '()           ; strict-pat
  309.               '(#f))))      ; type
  310.  
  311.       (set! *bb* '())
  312.       (set! *bbs* '())
  313.       (set! *global-env* '())
  314.     
  315.       (set! proc-tree '())
  316.       (set! proc-queue '())
  317.       (set! constant-vars '())
  318.       (set! known-procs '())
  319.  
  320.       (clear-context)
  321.  
  322.       proc)))
  323.  
  324. (define *bb* '())
  325. (define *bbs* '())
  326. (define *global-env* '())
  327.  
  328. (define proc-tree '())
  329. (define proc-queue '())
  330. (define constant-vars '())
  331. (define known-procs '())
  332.  
  333. (define trace-indentation '())
  334.  
  335. (define (trace-indent info-port)
  336.   (set! trace-indentation (+ trace-indentation 1))
  337.   (if info-port
  338.     (begin
  339.       (newline info-port)
  340.       (let loop ((i trace-indentation))
  341.         (if (> i 0)
  342.           (begin (display "  " info-port) (loop (- i 1))))))))
  343.  
  344. (define (trace-unindent info-port)
  345.   (set! trace-indentation (- trace-indentation 1)))
  346.  
  347. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  348.  
  349. (define (gen-define var node info-port)
  350.   (if (prc? node)
  351.  
  352.     (let* ((p-bbs         *bbs*)
  353.            (p-bb          *bb*)
  354.            (p-proc-tree   proc-tree)
  355.            (p-proc-queue  proc-queue)
  356.            (p-known-procs known-procs)
  357.            (p-context     (current-context))
  358.            (bbs           (make-bbs))
  359.            (lbl1          (bbs-new-lbl! bbs)) ; arg check entry point
  360.            (lbl2          (bbs-new-lbl! bbs)) ; no arg check entry point
  361.            (context       (entry-context node '()))
  362.            (frame         (context->frame
  363.                             context
  364.                             (set-union (free-variables (prc-body node))
  365.                                        ret-var-set)))
  366.            (bb1           (make-bb
  367.                             (make-LABEL-PROC
  368.                               lbl1
  369.                               (length (prc-parms node))
  370.                               (prc-min node)
  371.                               (prc-rest node)
  372.                               #f
  373.                               frame
  374.                               (source-comment node))
  375.                             bbs))
  376.            (bb2           (make-bb
  377.                             (make-LABEL-SIMP
  378.                               lbl2
  379.                               frame
  380.                               (source-comment node))
  381.                             bbs)))
  382.  
  383.       (define (do-body)
  384.         (gen-proc node bb2 context info-port)
  385.         (let loop ()
  386.           (if (pair? proc-queue)
  387.             (let ((x (car proc-queue)))
  388.               (set! proc-queue (cdr proc-queue))
  389.               (gen-proc (car x) (cadr x) (caddr x) info-port)
  390.               (trace-unindent info-port)
  391.               (loop))))
  392.         (trace-unindent info-port)
  393.         (bbs-purify! *bbs*))
  394.  
  395.       (context-entry-bb-set! context bb1)
  396.       (bbs-entry-lbl-num-set! bbs lbl1)
  397.       (bb-put-branch! bb1
  398.         (make-JUMP (make-lbl lbl2) #f #f frame (source-comment node)))
  399.       (set! *bbs* bbs)
  400.       (set! proc-tree '())
  401.       (set! proc-queue '())
  402.       (set! known-procs '())
  403.       (if (constant-var? var)
  404.         (let-constant-var var (make-lbl lbl1)
  405.           (lambda ()
  406.             (add-known-proc lbl1 node)
  407.             (do-body)))
  408.         (do-body))
  409.       (set! *bbs* p-bbs)
  410.       (set! *bb* p-bb)
  411.       (set! proc-tree p-proc-tree)
  412.       (set! proc-queue p-proc-queue)
  413.       (set! known-procs p-known-procs)
  414.       (restore-context p-context)
  415.       (let* ((x (assq var constant-vars))
  416.              (proc (if x
  417.                      (let ((p (cdr x)))
  418.                        (proc-obj-code-set! (obj-val p) bbs)
  419.                        p)
  420.                      (make-obj
  421.                        (make-proc-obj
  422.                          (symbol->string (var-name var)) ; name
  423.                          #f                  ; primitive?
  424.                          bbs                 ; code
  425.                          (call-pattern node) ; call-pat
  426.                          #t                  ; side-effects?
  427.                          '()                 ; strict-pat
  428.                          '(#f))))))          ; type
  429.         (put-copy proc
  430.                   (make-glo (var-name var))
  431.                   #f
  432.                   ret-var-set)))
  433.  
  434.     (put-copy (gen-node node ret-var-set 'need)
  435.               (make-glo (var-name var))
  436.               #f
  437.               ret-var-set)))
  438.  
  439. (define (call-pattern node)
  440.   (make-pattern (prc-min node) (length (prc-parms node)) (prc-rest node)))
  441.  
  442. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  443. ;
  444. ; Runtime context manipulation (i.e. where the variables are, what registers
  445. ; are in use, etc.)
  446.  
  447. ; runtime context description: nb-slots = number of slots presently allocated
  448. ; for the current frame on the stack, slots = list of variables associated with
  449. ; each slot (topmost slot first), regs = list of variables contained in each
  450. ; register, closed = list of variables which are closed with respect to the
  451. ; current procedure, interrupt = what is the maximum number of PVM instructions
  452. ; that can be executed before doing an interrupt check and have interrupts been
  453. ; checked since entry to this procedure, entry-bb = the entry basic block for
  454. ; the procedure containing this context (must have a label of type PROC).
  455.  
  456. (define (make-context nb-slots slots regs closed interrupt entry-bb)
  457.   (vector nb-slots slots regs closed interrupt entry-bb))
  458.  
  459. (define (context-nb-slots x)        (vector-ref x 0))
  460. (define (context-slots x)           (vector-ref x 1))
  461. (define (context-regs x)            (vector-ref x 2))
  462. (define (context-closed x)          (vector-ref x 3))
  463. (define (context-interrupt x)       (vector-ref x 4))
  464. (define (context-entry-bb x)        (vector-ref x 5))
  465. (define (context-entry-bb-set! x y) (vector-set! x 5 y))
  466.  
  467. (define nb-slots  '())
  468. (define slots     '())
  469. (define regs      '())
  470. (define closed    '())
  471. (define interrupt '())
  472. (define entry-bb  '())
  473.  
  474. (define (restore-context context)
  475.   (set! nb-slots   (context-nb-slots context))
  476.   (set! slots      (context-slots context))
  477.   (set! regs       (context-regs context))
  478.   (set! closed     (context-closed context))
  479.   (set! interrupt  (context-interrupt context))
  480.   (set! entry-bb   (context-entry-bb context)))
  481.  
  482. (define (clear-context)
  483.   (restore-context (make-context '() '() '() '() '() '())))
  484.  
  485. (define (current-context)
  486.   (make-context nb-slots slots regs closed interrupt entry-bb))
  487.  
  488. (define (current-frame live)
  489.   (make-frame nb-slots slots regs closed live))
  490.  
  491. (define (context->frame context live)
  492.   (make-frame (context-nb-slots context)
  493.               (context-slots context)
  494.               (context-regs context)
  495.               (context-closed context)
  496.               live))
  497.  
  498. (define (make-interrupt checked? delta)
  499.   (cons checked? delta))
  500.  
  501. (define (interrupt-checked? x) (car x))
  502. (define (interrupt-delta x) (cdr x))
  503.  
  504. (define (entry-interrupt)
  505.   (make-interrupt #f (- interrupt-period interrupt-head)))
  506.  
  507. (define (return-interrupt interrupt)
  508.   (let ((delta (interrupt-delta interrupt)))
  509.     (make-interrupt (interrupt-checked? interrupt)
  510.                     (+ interrupt-head (max delta interrupt-tail)))))
  511.  
  512. (define (interrupt-merge interrupt other-interrupt)
  513.   (make-interrupt
  514.     (or (interrupt-checked? interrupt)
  515.         (interrupt-checked? other-interrupt))
  516.     (max (interrupt-delta interrupt)
  517.          (interrupt-delta other-interrupt))))
  518.  
  519. (define interrupt-period #f) ; Lmax
  520. (set! interrupt-period 90)
  521.  
  522. (define interrupt-head #f) ; E
  523. (set! interrupt-head 15)
  524.  
  525. (define interrupt-tail #f) ; R
  526. (set! interrupt-tail 15)
  527.  
  528. ; (entry-context proc closed) returns the context in existence upon entry to
  529. ; the procedure `proc'
  530.  
  531. (define (entry-context proc closed)
  532.  
  533.   (define (empty-vars-list n)
  534.     (if (> n 0)
  535.       (cons empty-var (empty-vars-list (- n 1)))
  536.       '()))
  537.  
  538.   (let* ((parms (prc-parms proc))
  539.          (pc (target.label-info (prc-min proc) (length parms) (prc-rest proc) (not (null? closed))))
  540.          (fs (pcontext-fs pc))
  541.          (slots-list (empty-vars-list fs))
  542.          (regs-list (empty-vars-list target.nb-regs)))
  543.  
  544.     (define (assign-var-to-loc var loc)
  545.       (let ((x (cond ((reg? loc)
  546.                       (let ((i (reg-num loc)))
  547.                         (if (<= i target.nb-regs)
  548.                           (nth-after regs-list i)
  549.                           (compiler-internal-error
  550.                             "entry-context, reg out of bound in back-end's pcontext"))))
  551.                      ((stk? loc)
  552.                       (let ((i (stk-num loc)))
  553.                         (if (<= i fs)
  554.                           (nth-after slots-list (- fs i))
  555.                           (compiler-internal-error
  556.                             "entry-context, stk out of bound in back-end's pcontext"))))
  557.                      (else
  558.                       (compiler-internal-error
  559.                         "entry-context, loc other than reg or stk in back-end's pcontext")))))
  560.         (if (eq? (car x) empty-var)
  561.           (set-car! x var)
  562.           (compiler-internal-error
  563.             "entry-context, duplicate location in back-end's pcontext"))))
  564.  
  565.     (let loop ((l (pcontext-map pc)))
  566.       (if (not (null? l))
  567.         (let* ((couple (car l))
  568.                (name (car couple))
  569.                (loc (cdr couple)))
  570.           (cond ((eq? name 'return)
  571.                  (assign-var-to-loc ret-var loc))
  572.                 ((eq? name 'closure-env)
  573.                  (assign-var-to-loc closure-env-var loc))
  574.                 (else
  575.                  (assign-var-to-loc (list-ref parms (- name 1)) loc)))
  576.           (loop (cdr l)))))
  577.  
  578.     (make-context fs slots-list regs-list closed (entry-interrupt) #f)))
  579.  
  580. (define (get-var opnd)
  581.   (cond ((glo? opnd)
  582.          (env-lookup-global-var *global-env* (glo-name opnd)))
  583.         ((reg? opnd)
  584.          (list-ref regs (reg-num opnd)))
  585.         ((stk? opnd)
  586.          (list-ref slots (- nb-slots (stk-num opnd))))
  587.         (else
  588.          (compiler-internal-error
  589.            "get-var, location must be global, register or stack slot"))))
  590.  
  591. (define (put-var opnd new)
  592.  
  593.   (define (put-v opnd new)
  594.     (cond ((reg? opnd)
  595.            (set! regs (replace-nth regs (reg-num opnd) new)))
  596.           ((stk? opnd)
  597.            (set! slots (replace-nth slots (- nb-slots (stk-num opnd)) new)))
  598.           (else
  599.            (compiler-internal-error
  600.              "put-var, location must be register or stack slot, for var:"
  601.              (var-name new)))))
  602.  
  603.   (if (eq? new ret-var) ; only keep one copy of return address
  604.     (let ((x (var->opnd ret-var)))
  605.       (and x (put-v x empty-var))))
  606.   (put-v opnd new))
  607.  
  608. (define (flush-regs)
  609.   (set! regs '()))
  610.  
  611. (define (push-slot)
  612.   (set! nb-slots (+ nb-slots 1))
  613.   (set! slots    (cons empty-var slots)))
  614.  
  615. (define (dealloc-slots n)
  616.   (set! nb-slots (- nb-slots n))
  617.   (set! slots    (nth-after slots n)))
  618.  
  619. (define (pop-slot)
  620.   (dealloc-slots 1))
  621.  
  622. (define (replace-nth l i v)
  623.   (if (null? l)
  624.     (if (= i 0)
  625.       (list v)
  626.       (cons empty-var (replace-nth l (- i 1) v)))
  627.     (if (= i 0)
  628.       (cons v (cdr l))
  629.       (cons (car l) (replace-nth (cdr l) (- i 1) v)))))
  630.  
  631. (define (live-vars live)
  632.   (if (not (set-empty? (set-intersection live (list->set closed))))
  633.     (set-adjoin live closure-env-var)
  634.     live))
  635.  
  636. (define (dead-slots live)
  637.   (let ((live-v (live-vars live)))
  638.     (define (loop s l i)
  639.       (cond ((null? l) (list->set (reverse s)))
  640.             ((set-member? (car l) live-v)
  641.              (loop s (cdr l) (- i 1)))
  642.             (else
  643.              (loop (cons i s) (cdr l) (- i 1)))))
  644.     (loop '() slots nb-slots)))
  645.  
  646. (define (live-slots live)
  647.   (let ((live-v (live-vars live)))
  648.     (define (loop s l i)
  649.       (cond ((null? l) (list->set (reverse s)))
  650.             ((set-member? (car l) live-v)
  651.              (loop (cons i s) (cdr l) (- i 1)))
  652.             (else
  653.              (loop s (cdr l) (- i 1)))))
  654.     (loop '() slots nb-slots)))
  655.  
  656. (define (dead-regs live)
  657.   (let ((live-v (live-vars live)))
  658.     (define (loop s l i)
  659.       (cond ((>= i target.nb-regs) (list->set (reverse s)))
  660.             ((null? l)
  661.              (loop (cons i s) l (+ i 1)))
  662.             ((and (set-member? (car l) live-v)
  663.                   (not (memq (car l) slots)))
  664.              (loop s (cdr l) (+ i 1)))
  665.             (else
  666.              (loop (cons i s) (cdr l) (+ i 1)))))
  667.     (loop '() regs 0)))
  668.  
  669. (define (live-regs live)
  670.   (let ((live-v (live-vars live)))
  671.     (define (loop s l i)
  672.       (cond ((null? l) (list->set (reverse s)))
  673.             ((and (set-member? (car l) live-v)
  674.                   (not (memq (car l) slots)))
  675.              (loop (cons i s) (cdr l) (+ i 1)))
  676.             (else
  677.              (loop s (cdr l) (+ i 1)))))
  678.     (loop '() regs 0)))
  679.  
  680. (define (lowest-dead-slot live)
  681.   (make-stk (or (lowest (dead-slots live)) (+ nb-slots 1))))
  682.  
  683. (define (highest-live-slot live)
  684.   (make-stk (or (highest (live-slots live)) 0)))
  685.  
  686. (define (lowest-dead-reg live)
  687.   (let ((x (lowest (set-remove (dead-regs live) 0))))
  688.     (if x (make-reg x) #f)))
  689.  
  690. (define (highest-dead-reg live)
  691.   (let ((x (highest (dead-regs live))))
  692.     (if x (make-reg x) #f)))
  693.  
  694. (define (highest set) ; return highest number in the set
  695.   (if (set-empty? set) #f (apply max (set->list set))))
  696.  
  697. (define (lowest set) ; return lowest number in the set
  698.   (if (set-empty? set) #f (apply min (set->list set))))
  699.  
  700. (define (above set n) ; return numbers above n in the set
  701.   (set-keep (lambda (x) (> x n)) set))
  702.   
  703. (define (below set n) ; return numbers below n in the set
  704.   (set-keep (lambda (x) (< x n)) set))
  705.   
  706. (define (var->opnd var)
  707.   (let ((x (assq var constant-vars)))
  708.     (if x
  709.       (cdr x)
  710.       (if (global? var)
  711.         (make-glo (var-name var))
  712.         (let ((n (pos-in-list var regs)))
  713.           (if n
  714.             (make-reg n)
  715.             (let ((n (pos-in-list var slots)))
  716.               (if n
  717.                 (make-stk (- nb-slots n))
  718.                 (let ((n (pos-in-list var closed)))
  719.                   (if n
  720.                     (make-clo (var->opnd closure-env-var) (+ n 1))
  721.                     (compiler-internal-error
  722.                       "var->opnd, variable is not accessible:" (var-name var))))))))))))
  723.  
  724. (define (source-comment node)
  725.   (let ((x (make-comment)))
  726.     (comment-put! x 'SOURCE (node-source node))
  727.     x))
  728.  
  729. ;------------------------------------------------------------------------------
  730.  
  731. (define (add-constant-var var opnd)
  732.   (set! constant-vars (cons (cons var opnd) constant-vars)))
  733.  
  734. (define (let-constant-var var opnd thunk)
  735.   (let* ((x (assq var constant-vars))
  736.          (temp (cdr x)))
  737.     (set-cdr! x opnd)
  738.     (thunk)
  739.     (set-cdr! x temp)))
  740.  
  741. (define (constant-var? var)
  742.   (assq var constant-vars))
  743.  
  744. (define (not-constant-var? var)
  745.   (not (constant-var? var)))
  746.  
  747. (define (add-known-proc label proc)
  748.   (set! known-procs (cons (cons label proc) known-procs)))
  749.  
  750. ;------------------------------------------------------------------------------
  751. ;
  752. ; generate code for a procedure
  753.  
  754. (define (gen-proc proc bb context info-port)
  755.   (trace-indent info-port)
  756.   (if info-port
  757.     (if (prc-name proc)
  758.       (display (prc-name proc) info-port)
  759.       (display "\"unknown\"" info-port)))
  760.   (let ((lbl (bb-lbl-num bb))
  761.         (live (set-union (free-variables (prc-body proc)) ret-var-set)))
  762.     (set! *bb* bb)
  763.     (restore-context context)
  764.     (gen-node (prc-body proc) ret-var-set 'tail)))
  765.  
  766. (define (schedule-gen-proc proc closed-list)
  767.   (let* ((lbl1 (bbs-new-lbl! *bbs*)) ; arg check entry point
  768.          (lbl2 (bbs-new-lbl! *bbs*)) ; no arg check entry point
  769.          (context (entry-context proc closed-list))
  770.          (frame (context->frame
  771.                   context
  772.                   (set-union (free-variables (prc-body proc))
  773.                              ret-var-set)))
  774.          (bb1 (make-bb
  775.                 (make-LABEL-PROC
  776.                   lbl1
  777.                   (length (prc-parms proc))
  778.                   (prc-min proc)
  779.                   (prc-rest proc)
  780.                   (not (null? closed-list))
  781.                   frame
  782.                   (source-comment proc))
  783.                 *bbs*))
  784.          (bb2 (make-bb
  785.                 (make-LABEL-SIMP
  786.                   lbl2
  787.                   frame
  788.                   (source-comment proc))
  789.                 *bbs*)))
  790.     (context-entry-bb-set! context bb1)
  791.     (bb-put-branch! bb1
  792.       (make-JUMP (make-lbl lbl2) #f #f frame (source-comment proc)))
  793.     (set! proc-tree (cons (cons lbl1 (bb-lbl-num entry-bb)) proc-tree))
  794.     (set! proc-queue (cons (list proc bb2 context) proc-queue))
  795.     (make-lbl lbl1)))
  796.  
  797. ;------------------------------------------------------------------------------
  798. ;
  799. ; generate code for an expression
  800.  
  801. (define (gen-node node live why)
  802.  
  803.   (cond ((cst? node)
  804.          (gen-return
  805.            (make-obj (cst-val node))
  806.            why
  807.            node))
  808.  
  809.         ((ref? node)
  810.          (let* ((var (ref-var node))
  811.                 (name (var-name var)))
  812.            (gen-return
  813.              (cond ((eq? why 'side)
  814.                     (make-obj undef-object))
  815.                    ((global? var)
  816.                     (let ((prim (target.prim-info* name (node-decl node))))
  817.                       (if prim (make-obj prim) (var->opnd var))))
  818.                    (else
  819.                     (var->opnd var)))
  820.              why
  821.              node)))
  822.  
  823.         ((set? node)
  824.          (let* ((src (gen-node (set-val node)
  825.                                (set-adjoin live (set-var node))
  826.                                'keep))
  827.                 (dst (var->opnd (set-var node))))
  828.            (put-copy src dst #f live)
  829.            (gen-return (make-obj undef-object) why node)))
  830.  
  831.         ((def? node)
  832.          (compiler-internal-error
  833.            "gen-node, 'def' node not at root of parse tree"))
  834.  
  835.         ((tst? node)
  836.          (gen-tst node live why))
  837.  
  838.         ((conj? node)
  839.          (gen-conj/disj node live why))
  840.  
  841.         ((disj? node)
  842.          (gen-conj/disj node live why))
  843.  
  844.         ((prc? node)
  845.          (let* ((closed (not-constant-closed-vars node))
  846.                 (closed-list (set->list closed))
  847.                 (proc-lbl (schedule-gen-proc node closed-list)))
  848.            (let ((opnd
  849.                   (if (null? closed-list)
  850.                     (begin
  851.                       (add-known-proc (lbl-num proc-lbl) node)
  852.                       proc-lbl)
  853.                     (begin
  854.                       (dealloc-slots (- nb-slots
  855.                                         (stk-num (highest-live-slot
  856.                                                    (set-union closed live)))))
  857.                       (push-slot)
  858.                       (let ((slot (make-stk nb-slots))
  859.                             (var (make-temp-var 'closure)))
  860.                         (put-var slot var)
  861.                         (bb-put-non-branch! *bb*
  862.                           (make-MAKE_CLOSURES
  863.                             (list (make-closure-parms
  864.                                     slot
  865.                                     (lbl-num proc-lbl)
  866.                                     (map var->opnd closed-list)))
  867.                             (current-frame (set-adjoin live var))
  868.                             (source-comment node)))
  869.                         slot)))))
  870.              (gen-return opnd why node))))
  871.  
  872.         ((app? node)
  873.          (gen-call node live why))
  874.  
  875.         ((fut? node)
  876.          (gen-fut node live why))
  877.  
  878.         (else
  879.          (compiler-internal-error
  880.            "gen-node, unknown parse tree node type:" node))))
  881.  
  882. (define (gen-return opnd why node)
  883.   (cond ((eq? why 'tail)
  884.          (let ((var (make-temp-var 'result)))
  885.            (put-copy opnd target.proc-result var ret-var-set)
  886.            (let ((ret-opnd (var->opnd ret-var)))
  887.              (seal-bb (intr-checks? (node-decl node)) 'RETURN)
  888.              (dealloc-slots nb-slots)
  889.              (bb-put-branch! *bb*
  890.                (make-JUMP ret-opnd
  891.                           #f
  892.                           #f
  893.                           (current-frame (set-singleton var))
  894.                           (source-comment node))))))
  895.         (else
  896.          opnd)))
  897.  
  898. (define (not-constant-closed-vars val)
  899.   (set-keep not-constant-var? (free-variables val)))
  900.  
  901. ;------------------------------------------------------------------------------
  902. ;
  903. ; generate code for a conditional
  904.  
  905. (define (predicate node live cont)
  906.  
  907.   (define (cont* true-lbl false-lbl)
  908.     (cont false-lbl true-lbl))
  909.  
  910.   (define (generic-true-test)
  911.     (predicate-test node live **NOT-proc-obj '0 (list node) cont*))
  912.  
  913.   (cond ((or (conj? node) (disj? node))
  914.          (predicate-conj/disj node live cont))
  915.  
  916.         ((app? node)
  917.          (let ((proc (node->proc (app-oper node))))
  918.            (if proc
  919.              (let ((spec (specialize-for-call proc (node-decl node))))
  920.                (if (and (proc-obj-test spec)
  921.                         (nb-args-conforms? (length (app-args node))
  922.                                            (proc-obj-call-pat spec)))
  923.  
  924.                  (if (eq? spec **NOT-proc-obj)
  925.                    (predicate (car (app-args node)) live cont*)
  926.                    (predicate-test node live spec
  927.                                    (proc-obj-strict-pat proc)
  928.                                    (app-args node)
  929.                                    cont))
  930.  
  931.                  (generic-true-test)))
  932.  
  933.              (generic-true-test))))
  934.  
  935.         (else
  936.          (generic-true-test))))
  937.  
  938. (define (predicate-conj/disj node live cont)
  939.   (let* ((pre (if (conj? node) (conj-pre node) (disj-pre node)))
  940.          (alt (if (conj? node) (conj-alt node) (disj-alt node)))
  941.          (alt-live (set-union live (free-variables alt))))
  942.  
  943.     (predicate pre alt-live
  944.  
  945.       (lambda (true-lbl false-lbl)
  946.  
  947.         (let ((pre-context (current-context)))
  948.  
  949.           (set! *bb* (make-bb
  950.                        (make-LABEL-SIMP
  951.                          (if (conj? node) true-lbl false-lbl)
  952.                          (current-frame alt-live)
  953.                          (source-comment pre))
  954.                        *bbs*))
  955.  
  956.           (predicate alt live
  957.  
  958.             (lambda (true-lbl2 false-lbl2)
  959.  
  960.               (let ((alt-context (current-context)))
  961.  
  962.                 (restore-context pre-context)
  963.  
  964.                 (set! *bb* (make-bb
  965.                              (make-LABEL-SIMP
  966.                                (if (conj? node) false-lbl true-lbl)
  967.                                (current-frame live)
  968.                                (source-comment alt))
  969.                              *bbs*))
  970.  
  971.                 (merge-contexts-and-seal-bb
  972.                   alt-context
  973.                   live
  974.                   (intr-checks? (node-decl node))
  975.                   'INTERNAL)
  976.  
  977.                 (bb-put-branch! *bb*
  978.                   (make-JUMP
  979.                     (make-lbl (if (conj? node) false-lbl2 true-lbl2))
  980.                     #f
  981.                     #f
  982.                     (current-frame live)
  983.                     (source-comment node)))
  984.  
  985.                 (cont true-lbl2 false-lbl2)))))))))
  986.  
  987. (define (predicate-test node live test strict-pat args cont)
  988.   (let loop ((args* args) (liv live) (vars* '()))
  989.     (if (not (null? args*))
  990.  
  991.       (let* ((needed (vals-live-vars liv (cdr args*)))
  992.              (var
  993.               (save-var (gen-node (car args*) needed 'need)
  994.                         (make-temp-var 'predicate)
  995.                         needed)))
  996.         (loop (cdr args*) (set-adjoin liv var) (cons var vars*)))
  997.  
  998.       (let* ((true-lbl (bbs-new-lbl! *bbs*))
  999.              (false-lbl (bbs-new-lbl! *bbs*)))
  1000.  
  1001.         (seal-bb (intr-checks? (node-decl node)) 'INTERNAL)
  1002.  
  1003.         (bb-put-branch! *bb*
  1004.           (make-COND
  1005.             test
  1006.             (flag-pot-fut (map var->opnd (reverse vars*))
  1007.                           (lambda (i) (pattern-member? i strict-pat))
  1008.                           (node-decl node))
  1009.             true-lbl
  1010.             false-lbl
  1011.             #f
  1012.             (current-frame live)
  1013.             (source-comment node)))
  1014.  
  1015.         (cont true-lbl false-lbl)))))
  1016.  
  1017. (define (gen-tst node live why)
  1018.  
  1019.   (let ((pre (tst-pre node))
  1020.         (con (tst-con node))
  1021.         (alt (tst-alt node)))
  1022.  
  1023.     (predicate pre (set-union live (free-variables con) (free-variables alt))
  1024.  
  1025.       (lambda (true-lbl false-lbl)
  1026.  
  1027.         (let ((pre-context (current-context))
  1028.               (true-bb (make-bb
  1029.                          (make-LABEL-SIMP
  1030.                            true-lbl
  1031.                            (current-frame (set-union live (free-variables con)))
  1032.                            (source-comment con))
  1033.                          *bbs*))
  1034.               (false-bb (make-bb
  1035.                           (make-LABEL-SIMP
  1036.                             false-lbl
  1037.                             (current-frame (set-union live (free-variables alt)))
  1038.                             (source-comment alt))
  1039.                           *bbs*)))
  1040.  
  1041.           (set! *bb* true-bb)
  1042.  
  1043.           (let ((con-opnd (gen-node con live why)))
  1044.  
  1045.             (if (eq? why 'tail)
  1046.  
  1047.               (begin
  1048.                 (restore-context pre-context)
  1049.                 (set! *bb* false-bb)
  1050.                 (gen-node alt live why))
  1051.  
  1052.               (let* ((result-var (make-temp-var 'result))
  1053.                      (live-after (set-adjoin live result-var)))
  1054.  
  1055.                 (save-opnd-to-reg con-opnd
  1056.                                   target.proc-result
  1057.                                   result-var
  1058.                                   live)
  1059.  
  1060.                 (let ((con-context (current-context))
  1061.                       (con-bb *bb*))
  1062.                   (restore-context pre-context)
  1063.                   (set! *bb* false-bb)
  1064.  
  1065.                   (save-opnd-to-reg (gen-node alt live why)
  1066.                                     target.proc-result
  1067.                                     result-var
  1068.                                     live)
  1069.  
  1070.                   (let ((next-lbl (bbs-new-lbl! *bbs*))
  1071.                         (alt-bb *bb*))
  1072.  
  1073.                     (if (> (context-nb-slots con-context) nb-slots)
  1074.                       (begin
  1075.                         (seal-bb (intr-checks? (node-decl node)) 'INTERNAL)
  1076.                         (let ((alt-context (current-context)))
  1077.                           (restore-context con-context)
  1078.                           (set! *bb* con-bb)
  1079.                           (merge-contexts-and-seal-bb
  1080.                             alt-context
  1081.                             live-after
  1082.                             (intr-checks? (node-decl node))
  1083.                             'INTERNAL)))
  1084.                       (let ((alt-context (current-context)))
  1085.                         (restore-context con-context)
  1086.                         (set! *bb* con-bb)
  1087.                         (seal-bb (intr-checks? (node-decl node)) 'INTERNAL)
  1088.                         (let ((con-context* (current-context)))
  1089.                           (restore-context alt-context)
  1090.                           (set! *bb* alt-bb)
  1091.                           (merge-contexts-and-seal-bb
  1092.                             con-context*
  1093.                             live-after
  1094.                             (intr-checks? (node-decl node))
  1095.                             'INTERNAL))))
  1096.  
  1097.                     (let ((frame (current-frame live-after)))
  1098.  
  1099.                       (bb-put-branch! con-bb
  1100.                         (make-JUMP
  1101.                           (make-lbl next-lbl)
  1102.                           #f
  1103.                           #f
  1104.                           frame
  1105.                           (source-comment node)))
  1106.  
  1107.                       (bb-put-branch! alt-bb
  1108.                         (make-JUMP
  1109.                           (make-lbl next-lbl)
  1110.                           #f
  1111.                           #f
  1112.                           frame
  1113.                           (source-comment node)))
  1114.  
  1115.                       (set! *bb* (make-bb
  1116.                                    (make-LABEL-SIMP
  1117.                                      next-lbl
  1118.                                      frame
  1119.                                      (source-comment node))
  1120.                                    *bbs*))
  1121.  
  1122.                       target.proc-result)))))))))))
  1123.  
  1124. (define (nb-args-conforms? n call-pat)
  1125.   (pattern-member? n call-pat))
  1126.  
  1127. ; 'merge-contexts-and-seal-bb' generates code to transform the current
  1128. ; context (i.e. reg and stack values and frame size) to 'other-context' only
  1129. ; considering the variables in 'live'.
  1130.  
  1131. (define (merge-contexts-and-seal-bb other-context live checks? where)
  1132.   (let ((live-v (live-vars live))
  1133.         (other-nb-slots (context-nb-slots other-context))
  1134.         (other-regs (context-regs other-context))
  1135.         (other-slots (context-slots other-context))
  1136.         (other-interrupt (context-interrupt other-context))
  1137.         (other-entry-bb (context-entry-bb other-context)))
  1138.  
  1139.     (let loop1 ((i (- target.nb-regs 1)))
  1140.       (if (>= i 0)
  1141.  
  1142.         (let ((other-var (reg->var other-regs i))
  1143.               (var (reg->var regs i)))
  1144.           (if (and (not (eq? var other-var)) ; if var not already there and
  1145.                    (set-member? other-var live-v)) ; must keep other-var somewhere
  1146.             (let ((r (make-reg i)))
  1147.               (put-var r empty-var)
  1148.               (if (not (or (not (set-member? var live-v))
  1149.                            (memq var regs)
  1150.                            (memq var slots)))
  1151.                 (let ((top (make-stk (+ nb-slots 1))))
  1152.                   (put-copy r top var live-v)))
  1153.               (put-copy (var->opnd other-var) r other-var live-v)))
  1154.           (loop1 (- i 1)))))
  1155.  
  1156.     (let loop2 ((i 1))
  1157.       (if (<= i other-nb-slots)
  1158.  
  1159.         (let ((other-var (stk->var other-slots i))
  1160.               (var (stk->var slots i)))
  1161.           (if (and (not (eq? var other-var)) ; if var not already there and
  1162.                    (set-member? other-var live-v)) ; must keep other-var somewhere
  1163.             (let ((s (make-stk i)))
  1164.               (if (<= i nb-slots) (put-var s empty-var))
  1165.               (if (not (or (not (set-member? var live-v))
  1166.                            (memq var regs)
  1167.                            (memq var slots)))
  1168.                 (let ((top (make-stk (+ nb-slots 1))))
  1169.                   (put-copy s top var live-v)))
  1170.               (put-copy (var->opnd other-var) s other-var live-v))
  1171.             (if (> i nb-slots)
  1172.               (let ((top (make-stk (+ nb-slots 1))))
  1173.                 (put-copy (make-obj undef-object) top empty-var live-v))))
  1174.           (loop2 (+ i 1)))))
  1175.  
  1176.     (dealloc-slots (- nb-slots other-nb-slots))
  1177.  
  1178.     (let loop3 ((i (- target.nb-regs 1)))
  1179.       (if (>= i 0)
  1180.  
  1181.         (let ((other-var (reg->var other-regs i))
  1182.               (var (reg->var regs i)))
  1183.           (if (not (eq? var other-var))
  1184.             (put-var (make-reg i) empty-var))
  1185.           (loop3 (- i 1)))))
  1186.  
  1187.     (let loop4 ((i 1))
  1188.       (if (<= i other-nb-slots)
  1189.  
  1190.         (let ((other-var (stk->var other-slots i))
  1191.               (var (stk->var slots i)))
  1192.           (if (not (eq? var other-var))
  1193.             (put-var (make-stk i) empty-var))
  1194.           (loop4 (+ i 1)))))
  1195.  
  1196.     (seal-bb checks? where)
  1197.  
  1198.     (set! interrupt (interrupt-merge interrupt other-interrupt))
  1199.  
  1200.     (if (not (eq? entry-bb other-entry-bb))
  1201.       (compiler-internal-error
  1202.         "merge-contexts-and-seal-bb, entry-bb's do not agree"))))
  1203.  
  1204. (define (seal-bb checks? where)
  1205.  
  1206.   (define (last-pair l)
  1207.     (if (pair? (cdr l)) (last-pair (cdr l)) l))
  1208.  
  1209.   (define (intr-check-at split-point)
  1210.     (let loop ((i 0) (l1 (bb-non-branch-instrs *bb*)) (l2 '()))
  1211.       (if (< i split-point)
  1212.         (loop (+ i 1) (cdr l1) (cons (car l1) l2))
  1213.         (let* ((label-instr (bb-label-instr *bb*))
  1214.                (non-branch-instrs1 (reverse l2))
  1215.                (non-branch-instrs2 l1)
  1216.                (frame (pvm-instr-frame
  1217.                         (car (last-pair (cons label-instr
  1218.                                               non-branch-instrs1)))))
  1219.                (prec-bb (make-bb label-instr *bbs*))
  1220.                (new-lbl (bbs-new-lbl! *bbs*)))
  1221.           (bb-non-branch-instrs-set! prec-bb non-branch-instrs1)
  1222.           (bb-put-branch! prec-bb
  1223.             (make-JUMP (make-lbl new-lbl) #f #t frame #f))
  1224.           (bb-label-instr-set! *bb* (make-LABEL-SIMP new-lbl frame #f))
  1225.           (bb-non-branch-instrs-set! *bb* non-branch-instrs2)
  1226.           (set! interrupt (make-interrupt #t 0))))))
  1227.  
  1228.   (define (intr-check-at-end)
  1229.     (intr-check-at (length (bb-non-branch-instrs *bb*))))
  1230.  
  1231.   (define (impose-intr-check-constraints)
  1232.     (let ((n (+ (length (bb-non-branch-instrs *bb*)) 1))
  1233.           (delta (interrupt-delta interrupt)))
  1234.       (if (> (+ delta n) interrupt-period)
  1235.         (begin
  1236.           (intr-check-at (max (- interrupt-period delta) 0))
  1237.           (impose-intr-check-constraints)))))
  1238.  
  1239.   (if checks? (impose-intr-check-constraints))
  1240.  
  1241.   (let* ((n (+ (length (bb-non-branch-instrs *bb*)) 1))
  1242.          (delta (+ (interrupt-delta interrupt) n))
  1243.          (checked? (interrupt-checked? interrupt)))
  1244.     (if (and checks?
  1245.              (case where
  1246.                ((CALL)
  1247.                 (> delta (- interrupt-period interrupt-head)))
  1248.                ((TAIL-CALL)
  1249.                 (> delta interrupt-tail))
  1250.                ((RETURN)
  1251.                 (and checked? (> delta (+ interrupt-head interrupt-tail))))
  1252.                ((INTERNAL)
  1253.                 #f)
  1254.                (else
  1255.                 (compiler-internal-error "seal-bb, unknown 'where':" where))))
  1256.       (intr-check-at-end)
  1257.       (set! interrupt (make-interrupt checked? delta)))))
  1258.  
  1259. (define (reg->var regs i)
  1260.   (cond ((null? regs)
  1261.          '())
  1262.         ((> i 0)
  1263.          (reg->var (cdr regs) (- i 1)))
  1264.         (else
  1265.          (car regs))))
  1266.  
  1267. (define (stk->var slots i)
  1268.   (let ((j (- (length slots) i)))
  1269.     (if (< j 0)
  1270.       '()
  1271.       (list-ref slots j))))
  1272.  
  1273. ;------------------------------------------------------------------------------
  1274. ;
  1275. ; generate code for a conjunction or disjunction
  1276.  
  1277. (define (gen-conj/disj node live why)
  1278.  
  1279.   (let ((pre (if (conj? node) (conj-pre node) (disj-pre node)))
  1280.         (alt (if (conj? node) (conj-alt node) (disj-alt node))))
  1281.  
  1282.     (let ((needed (set-union live (free-variables alt)))
  1283.           (bool? (boolean-value? pre))
  1284.           (predicate-var (make-temp-var 'predicate)))
  1285.  
  1286.       (define (general-predicate node live cont)
  1287.         (let* ((con-lbl (bbs-new-lbl! *bbs*))
  1288.                (alt-lbl (bbs-new-lbl! *bbs*)))
  1289.  
  1290.           (save-opnd-to-reg (gen-node pre live 'need)
  1291.                             target.proc-result
  1292.                             predicate-var
  1293.                             live)
  1294.  
  1295.           (seal-bb (intr-checks? (node-decl node)) 'INTERNAL)
  1296.  
  1297.           (bb-put-branch! *bb*
  1298.             (make-COND
  1299.               **NOT-proc-obj
  1300.               (flag-pot-fut (list target.proc-result)
  1301.                             (lambda (i) #t)
  1302.                             (node-decl node))
  1303.               alt-lbl
  1304.               con-lbl
  1305.               #f
  1306.               (current-frame (set-adjoin live predicate-var))
  1307.               (source-comment node)))
  1308.  
  1309.           (cont con-lbl alt-lbl)))
  1310.  
  1311.       (define (alternative con-lbl alt-lbl)
  1312.         (let* ((pre-context (current-context))
  1313.                (result-var (make-temp-var 'result))
  1314.                (con-live (if bool? live (set-adjoin live predicate-var)))
  1315.                (alt-live (set-union live (free-variables alt)))
  1316.                (con-bb (make-bb
  1317.                          (make-LABEL-SIMP
  1318.                            con-lbl
  1319.                            (current-frame con-live)
  1320.                            (source-comment node))
  1321.                          *bbs*))
  1322.                (alt-bb (make-bb
  1323.                          (make-LABEL-SIMP
  1324.                            alt-lbl
  1325.                            (current-frame alt-live)
  1326.                            (source-comment alt))
  1327.                          *bbs*)))
  1328.  
  1329.           (if bool?
  1330.             (begin
  1331.               (set! *bb* con-bb)
  1332.               (save-opnd-to-reg (make-obj (if (conj? node) false-object #t))
  1333.                                 target.proc-result
  1334.                                 result-var
  1335.                                 live))
  1336.             (put-var (var->opnd predicate-var) result-var))
  1337.  
  1338.           (let ((con-context (current-context)))
  1339.  
  1340.             (set! *bb* alt-bb)
  1341.  
  1342.             (restore-context pre-context)
  1343.  
  1344.             (let ((alt-opnd (gen-node alt live why)))
  1345.  
  1346.               (if (eq? why 'tail)
  1347.  
  1348.                 (begin
  1349.                   (restore-context con-context)
  1350.                   (set! *bb* con-bb)
  1351.                   (let ((ret-opnd (var->opnd ret-var))
  1352.                         (result-set (set-singleton result-var)))
  1353.                     (seal-bb (intr-checks? (node-decl node)) 'RETURN)
  1354.                     (dealloc-slots nb-slots)
  1355.                     (bb-put-branch! *bb*
  1356.                       (make-JUMP ret-opnd
  1357.                                  #f
  1358.                                  #f
  1359.                                  (current-frame result-set)
  1360.                                  (source-comment node)))))
  1361.  
  1362.                 (let ((alt-context* (current-context))
  1363.                       (alt-bb* *bb*))
  1364.  
  1365.                   (restore-context con-context)
  1366.                   (set! *bb* con-bb)
  1367.                   (seal-bb (intr-checks? (node-decl node)) 'INTERNAL)
  1368.  
  1369.                   (let ((con-context* (current-context))
  1370.                         (next-lbl (bbs-new-lbl! *bbs*)))
  1371.  
  1372.                     (restore-context alt-context*)
  1373.                     (set! *bb* alt-bb*)
  1374.  
  1375.                     (save-opnd-to-reg alt-opnd
  1376.                                       target.proc-result
  1377.                                       result-var
  1378.                                       live)
  1379.  
  1380.                     (merge-contexts-and-seal-bb
  1381.                       con-context*
  1382.                       (set-adjoin live result-var)
  1383.                       (intr-checks? (node-decl node))
  1384.                       'INTERNAL)
  1385.  
  1386.                     (let ((frame (current-frame (set-adjoin live result-var))))
  1387.  
  1388.                       (bb-put-branch! *bb*
  1389.                         (make-JUMP
  1390.                           (make-lbl next-lbl)
  1391.                           #f
  1392.                           #f
  1393.                           frame
  1394.                           (source-comment node)))
  1395.  
  1396.                       (bb-put-branch! con-bb
  1397.                         (make-JUMP
  1398.                           (make-lbl next-lbl)
  1399.                           #f
  1400.                           #f
  1401.                           frame
  1402.                           (source-comment node)))
  1403.  
  1404.                       (set! *bb* (make-bb
  1405.                                    (make-LABEL-SIMP
  1406.                                      next-lbl
  1407.                                      frame
  1408.                                      (source-comment node))
  1409.                                    *bbs*))
  1410.  
  1411.                       target.proc-result))))))))
  1412.  
  1413.       ((if bool? predicate general-predicate) pre needed
  1414.        (lambda (true-lbl false-lbl)
  1415.          (if (conj? node)
  1416.            (alternative false-lbl true-lbl)
  1417.            (alternative true-lbl false-lbl)))))))
  1418.  
  1419. ;------------------------------------------------------------------------------
  1420. ;
  1421. ; generate code for a procedure call
  1422.  
  1423. (define (gen-call node live why)
  1424.   (let* ((oper (app-oper node))
  1425.          (args (app-args node))
  1426.          (nb-args (length args)))
  1427.  
  1428.     (if (and (prc? oper) ; applying a lambda-expr is like a 'let' or 'letrec'
  1429.              (not (prc-rest oper))
  1430.              (= (length (prc-parms oper)) nb-args))
  1431.  
  1432.       (gen-let (prc-parms oper) args (prc-body oper) live why)
  1433.  
  1434.       (if (inlinable-app? node)
  1435.  
  1436.         (let ((eval-order (arg-eval-order #f args))
  1437.               (vars (map (lambda (x) (cons x #f)) args)))
  1438.  
  1439.           (let loop ((l eval-order) (liv live))
  1440.             (if (not (null? l))
  1441.  
  1442.               (let* ((needed (vals-live-vars liv (map car (cdr l))))
  1443.                      (arg (car (car l)))
  1444.                      (pos (cdr (car l)))
  1445.                      (var
  1446.                       (save-var (gen-node arg needed 'need)
  1447.                                 (make-temp-var pos)
  1448.                                 needed)))
  1449.                 (set-cdr! (assq arg vars) var)
  1450.                 (loop (cdr l) (set-adjoin liv var)))
  1451.  
  1452.               (let ((loc (if (eq? why 'side)
  1453.                            (make-reg 0)
  1454.                            (or (lowest-dead-reg live) (lowest-dead-slot live)))))
  1455.  
  1456.                 (if (and (stk? loc) (> (stk-num loc) nb-slots)) (push-slot))
  1457.  
  1458.                 (let* ((args (map var->opnd (map cdr vars)))
  1459.                        (var (make-temp-var 'result))
  1460.                        (proc (node->proc oper))
  1461.                        (strict-pat (proc-obj-strict-pat proc)))
  1462.  
  1463.                   (if (not (eq? why 'side)) (put-var loc var))
  1464.  
  1465.                   (bb-put-non-branch! *bb*
  1466.                     (make-APPLY (specialize-for-call proc (node-decl node))
  1467.                                 (flag-pot-fut
  1468.                                   args
  1469.                                   (lambda (i) (pattern-member? i strict-pat))
  1470.                                   (node-decl node))
  1471.                                 (if (eq? why 'side) #f loc)
  1472.                                 (current-frame (if (eq? why 'side) live (set-adjoin live var)))
  1473.                                 (source-comment node)))
  1474.  
  1475.                   (gen-return loc why node))))))
  1476.  
  1477.       (let* ((calling-local-proc?
  1478.                (and (ref? oper)
  1479.                     (let ((opnd (var->opnd (ref-var oper))))
  1480.                       (and (lbl? opnd)
  1481.                            (let ((x (assq (lbl-num opnd) known-procs)))
  1482.                              (and x
  1483.                                   (let ((proc (cdr x)))
  1484.                                     (and (not (prc-rest proc))
  1485.                                          (= (prc-min proc) nb-args)
  1486.                                          (= (length (prc-parms proc)) nb-args)
  1487.                                          (lbl-num opnd)))))))))
  1488.              (jstate
  1489.                (get-jump-state
  1490.                  args
  1491.                  (if calling-local-proc?
  1492.                    (target.label-info nb-args nb-args #f #f)
  1493.                    (target.jump-info nb-args))))
  1494.              (in-stk (jump-state-in-stk jstate))
  1495.              (in-reg (jump-state-in-reg jstate))
  1496.              (eval-order (arg-eval-order (if calling-local-proc? #f oper) in-reg))
  1497.              (live-after (if (eq? why 'tail) (set-remove live ret-var) live))
  1498.              (live-for-regs (args-live-vars live eval-order))
  1499.              (return-lbl (if (eq? why 'tail) #f (bbs-new-lbl! *bbs*))))
  1500.  
  1501.         ; save regs on stack if they contain values needed after the call
  1502.         (save-regs (live-regs live-after)
  1503.                    (stk-live-vars live-for-regs in-stk why))
  1504.  
  1505.         (let ((frame-start (stk-num (highest-live-slot live-after))))
  1506.  
  1507.           (let loop1 ((l in-stk) (liv live-after) (i (+ frame-start 1)))
  1508.             (if (not (null? l))
  1509.  
  1510.               ; ==== FIRST: evaluate arguments that go onto stack
  1511.  
  1512.               (let ((arg (car l))
  1513.                     (slot (make-stk i))
  1514.                     (needed (set-union (stk-live-vars liv (cdr l) why)
  1515.                                        live-for-regs)))
  1516.                 (if arg
  1517.                   (let ((var (if (and (eq? arg 'return) (eq? why 'tail))
  1518.                                ret-var
  1519.                                (make-temp-var (- frame-start i)))))
  1520.                     (save-opnd-to-stk (if (eq? arg 'return)
  1521.                                         (if (eq? why 'tail)
  1522.                                           (var->opnd ret-var)
  1523.                                           (make-lbl return-lbl))
  1524.                                         (gen-node arg needed 'need))
  1525.                                       slot
  1526.                                       var
  1527.                                       needed)
  1528.                     (loop1 (cdr l) (set-adjoin liv var) (+ i 1)))
  1529.                   (begin
  1530.                     (if (> i nb-slots)
  1531.                       (put-copy (make-obj undef-object) slot empty-var liv))
  1532.                     (loop1 (cdr l) liv (+ i 1)))))
  1533.  
  1534.               (let loop2 ((l eval-order) (liv liv) (reg-map '()) (oper-var '()))
  1535.                 (if (not (null? l))
  1536.  
  1537.                   ; ==== SECOND: evaluate operator and args that go in registers
  1538.  
  1539.                   (let* ((arg (car (car l)))
  1540.                          (pos (cdr (car l)))
  1541.                          (needed (args-live-vars liv (cdr l)))
  1542.                          (var (if (and (eq? arg 'return) (eq? why 'tail))
  1543.                                 ret-var
  1544.                                 (make-temp-var pos)))
  1545.                          (opnd (if (eq? arg 'return)
  1546.                                  (if (eq? why 'tail)
  1547.                                    (var->opnd ret-var)
  1548.                                    (make-lbl return-lbl))
  1549.                                  (gen-node arg needed 'need))))
  1550.  
  1551.                     (if (eq? pos 'operator)
  1552.  
  1553.                       ; operator
  1554.  
  1555.                       (if (and (ref? arg)
  1556.                                (not (or (obj? opnd) (lbl? opnd))))
  1557.                         (loop2 (cdr l)
  1558.                                (set-adjoin liv (ref-var arg))
  1559.                                reg-map
  1560.                                (ref-var arg))
  1561.                         (begin
  1562.                           (save-arg opnd var needed)
  1563.                           (loop2 (cdr l)
  1564.                                  (set-adjoin liv var)
  1565.                                  reg-map
  1566.                                  var)))
  1567.  
  1568.                       ; return address or argument
  1569.  
  1570.                       (let ((reg (make-reg pos)))
  1571.  
  1572.                         (if (all-args-trivial? (cdr l))
  1573.                           (save-opnd-to-reg opnd reg var needed)
  1574.                           (save-in-slot opnd var needed))
  1575.  
  1576.                         (loop2 (cdr l)
  1577.                                (set-adjoin liv var)
  1578.                                (cons (cons pos var) reg-map)
  1579.                                oper-var))))
  1580.  
  1581.                   (let loop3 ((i (- target.nb-regs 1)))
  1582.                     (if (>= i 0)
  1583.  
  1584.                       ; ==== THIRD: reload spilled registers
  1585.  
  1586.                       (let ((couple (assq i reg-map)))
  1587.                         (if couple
  1588.                           (let ((var (cdr couple)))
  1589.                             (if (not (eq? (reg->var regs i) var))
  1590.                               (save-opnd-to-reg (var->opnd var) (make-reg i) var liv))))
  1591.                         (loop3 (- i 1)))
  1592.  
  1593.                       ; ==== FOURTH: jump to procedure
  1594.  
  1595.                       (let ((opnd (if calling-local-proc?
  1596.                                     (make-lbl (+ calling-local-proc? 1))
  1597.                                     (var->opnd oper-var))))
  1598.  
  1599.                         (seal-bb (intr-checks? (node-decl node))
  1600.                                  (if return-lbl 'CALL 'TAIL-CALL))
  1601.  
  1602.                         (dealloc-slots (- nb-slots (+ frame-start (length in-stk))))
  1603.  
  1604.                         (bb-put-branch! *bb*
  1605.                           (make-JUMP
  1606.                             (car (flag-pot-fut (list opnd)
  1607.                                                (lambda (i) #t)
  1608.                                                (node-decl node)))
  1609.                             (if calling-local-proc? #f nb-args)
  1610.                             #f
  1611.                             (current-frame liv)
  1612.                             (source-comment node)))
  1613.  
  1614.                         ; ==== FIFTH: put return label if there is one
  1615.  
  1616.                         (let ((result-var (make-temp-var 'result)))
  1617.  
  1618.                           (dealloc-slots (- nb-slots frame-start))
  1619.                           (flush-regs)
  1620.                           (put-var target.proc-result result-var)
  1621.  
  1622.                           (if return-lbl
  1623.                             (begin
  1624.                               (set! interrupt (return-interrupt interrupt))
  1625.                               (set! *bb*
  1626.                                 (make-bb
  1627.                                   (make-LABEL-RETURN
  1628.                                     return-lbl
  1629.                                     #f
  1630.                                     (current-frame (set-adjoin live result-var))
  1631.                                     (source-comment node))
  1632.                                   *bbs*))))
  1633.  
  1634.                           target.proc-result))))))))))))))
  1635.  
  1636. (define (contained-reg/slot opnd)
  1637.   (cond ((reg? opnd)
  1638.          opnd)
  1639.         ((stk? opnd)
  1640.          opnd)
  1641.         ((clo? opnd)
  1642.          (contained-reg/slot (clo-base opnd)))
  1643.         (else
  1644.          #f)))
  1645.  
  1646. (define (opnd-needed opnd needed)
  1647.   (let ((x (contained-reg/slot opnd)))
  1648.     (if x
  1649.       (set-adjoin needed (get-var x))
  1650.       needed)))
  1651.  
  1652. (define (save-opnd opnd live)
  1653.   (let ((slot (lowest-dead-slot live)))
  1654.     (put-copy opnd slot (get-var opnd) live)))
  1655.  
  1656. (define (save-regs regs live)
  1657.   (for-each (lambda (i) (save-opnd (make-reg i) live)) (set->list regs)))
  1658.  
  1659. (define (save-opnd-to-reg opnd reg var live)
  1660.   (if (set-member? (reg-num reg) (live-regs live))
  1661.     (save-opnd reg (opnd-needed opnd live)))
  1662.   (put-copy opnd reg var live))
  1663.  
  1664. (define (save-opnd-to-stk opnd stk var live)
  1665.   (if (set-member? (stk-num stk) (live-slots live))
  1666.     (save-opnd stk (opnd-needed opnd live)))
  1667.   (put-copy opnd stk var live))
  1668.  
  1669. (define (all-args-trivial? l)
  1670.   (if (null? l)
  1671.     #t
  1672.     (let ((arg (car (car l))))
  1673.       (or (eq? arg 'return)
  1674.           (and (trivial? arg)
  1675.                (all-args-trivial? (cdr l)))))))
  1676.  
  1677. (define (every-trivial? l)
  1678.   (or (null? l)
  1679.       (and (trivial? (car l))
  1680.            (every-trivial? (cdr l)))))
  1681.  
  1682. (define (trivial? node)
  1683.   (or (cst? node)
  1684.       (ref? node)
  1685.       (and (set? node) (trivial? (set-val node)))
  1686.       (and (inlinable-app? node) (every-trivial? (app-args node)))))
  1687.  
  1688. (define (inlinable-app? node)
  1689.   (if (app? node)
  1690.     (let ((proc (node->proc (app-oper node))))
  1691.       (and proc
  1692.            (let ((spec (specialize-for-call proc (node-decl node))))
  1693.              (and (proc-obj-inlinable spec)
  1694.                   (nb-args-conforms? (length (app-args node))
  1695.                                      (proc-obj-call-pat spec))))))
  1696.     #f))
  1697.  
  1698. (define (boolean-value? node)
  1699.   (or (and (conj? node)
  1700.            (boolean-value? (conj-pre node))
  1701.            (boolean-value? (conj-alt node)))
  1702.       (and (disj? node)
  1703.            (boolean-value? (disj-pre node))
  1704.            (boolean-value? (disj-alt node)))
  1705.       (boolean-app? node)))
  1706.  
  1707. (define (boolean-app? node)
  1708.   (if (app? node)
  1709.     (let ((proc (node->proc (app-oper node))))
  1710.       (if proc
  1711.         (eq? (type-name (proc-obj-type proc)) 'BOOLEAN)
  1712.         #f))
  1713.     #f))
  1714.  
  1715. (define (node->proc node)
  1716.   (cond ((cst? node)
  1717.          (if (proc-obj? (cst-val node))
  1718.            (cst-val node)
  1719.            #f))
  1720.         ((ref? node)
  1721.          (if (global? (ref-var node))
  1722.            (target.prim-info* (var-name (ref-var node)) (node-decl node))
  1723.            #f))
  1724.         (else
  1725.          #f)))
  1726.  
  1727. (define (specialize-for-call proc decl)
  1728.   ((proc-obj-specialize proc) decl))
  1729.  
  1730. (define (flag-pot-fut opnds strict? decl)
  1731.  
  1732.   (define (flag opnds i)
  1733.     (if (pair? opnds)
  1734.       (let ((opnd (car opnds)))
  1735.         (cons (if (and (not (or (lbl? opnd) (obj? opnd))) (strict? i))
  1736.                 (put-pot-fut opnd)
  1737.                 opnd)
  1738.               (flag (cdr opnds) (+ i 1))))
  1739.       '()))
  1740.  
  1741.   (if (autotouch? decl)
  1742.     (flag opnds 0)
  1743.     opnds))
  1744.  
  1745. (define (get-jump-state args pc)
  1746.  
  1747.   (define (empty-node-list n)
  1748.     (if (> n 0)
  1749.       (cons #f (empty-node-list (- n 1)))
  1750.       '()))
  1751.  
  1752.   (let* ((fs (pcontext-fs pc))
  1753.          (slots-list (empty-node-list fs))
  1754.          (regs-list (empty-node-list target.nb-regs)))
  1755.  
  1756.     (define (assign-node-to-loc var loc)
  1757.       (let ((x (cond ((reg? loc)
  1758.                       (let ((i (reg-num loc)))
  1759.                         (if (<= i target.nb-regs)
  1760.                           (nth-after regs-list i)
  1761.                           (compiler-internal-error
  1762.                             "jump-state, reg out of bound in back-end's pcontext"))))
  1763.                      ((stk? loc)
  1764.                       (let ((i (stk-num loc)))
  1765.                         (if (<= i fs)
  1766.                           (nth-after slots-list (- i 1))
  1767.                           (compiler-internal-error
  1768.                             "jump-state, stk out of bound in back-end's pcontext"))))
  1769.                      (else
  1770.                       (compiler-internal-error
  1771.                         "jump-state, loc other than reg or stk in back-end's pcontext")))))
  1772.         (if (not (car x))
  1773.           (set-car! x var)
  1774.           (compiler-internal-error
  1775.             "jump-state, duplicate location in back-end's pcontext"))))
  1776.  
  1777.     (let loop ((l (pcontext-map pc)))
  1778.       (if (not (null? l))
  1779.         (let* ((couple (car l))
  1780.                (name (car couple))
  1781.                (loc (cdr couple)))
  1782.           (cond ((eq? name 'return)
  1783.                  (assign-node-to-loc 'return loc))
  1784.                 (else
  1785.                  (assign-node-to-loc (list-ref args (- name 1)) loc)))
  1786.           (loop (cdr l)))))
  1787.  
  1788.     (vector slots-list regs-list)))
  1789.  
  1790. (define (jump-state-in-stk x) (vector-ref x 0))
  1791.  
  1792. (define (jump-state-in-reg x) (vector-ref x 1))
  1793.  
  1794. (define (arg-eval-order oper nodes)
  1795.  
  1796.   (define (loop nodes pos part1 part2)
  1797.  
  1798.     (cond ((null? nodes)
  1799.            (let ((p1 (reverse part1))
  1800.                  (p2 (free-vars-order part2)))
  1801.              (cond ((not oper)
  1802.                     (append p1 p2))
  1803.                    ((trivial? oper)
  1804.                     (append p1 p2 (list (cons oper 'operator))))
  1805.                    (else
  1806.                     (append (cons (cons oper 'operator) p1) p2)))))
  1807.  
  1808.           ((not (car nodes))
  1809.            (loop (cdr nodes)
  1810.                  (+ pos 1)
  1811.                  part1
  1812.                  part2))
  1813.  
  1814.           ((or (eq? (car nodes) 'return)
  1815.                (trivial? (car nodes)))
  1816.            (loop (cdr nodes)
  1817.                  (+ pos 1)
  1818.                  part1
  1819.                  (cons (cons (car nodes) pos) part2)))
  1820.  
  1821.           (else
  1822.            (loop (cdr nodes)
  1823.                  (+ pos 1)
  1824.                  (cons (cons (car nodes) pos) part1)
  1825.                  part2))))
  1826.  
  1827.   (loop nodes 0 '() '()))
  1828.  
  1829. (define (free-vars-order l)
  1830.   (let ((bins '())
  1831.         (ordered-args '()))
  1832.  
  1833.     (define (free-v x)
  1834.       (if (eq? x 'return)
  1835.         (set-empty)
  1836.         (free-variables x)))
  1837.  
  1838.     (define (add-to-bin! x)
  1839.       (let ((y (assq x bins)))
  1840.         (if y
  1841.           (set-cdr! y (+ (cdr y) 1))
  1842.           (set! bins (cons (cons x 1) bins)))))
  1843.  
  1844.     (define (payoff-if-removed node)
  1845.       (let ((x (free-v node)))
  1846.         (let loop ((l (set->list x)) (r 0))
  1847.           (if (null? l)
  1848.             r
  1849.             (let ((y (cdr (assq (car l) bins))))
  1850.               (loop (cdr l) (+ r (quotient 1000 (* y y))))))))) ; heuristic
  1851.  
  1852.     (define (remove-free-vars! x)
  1853.       (let loop ((l (set->list x)))
  1854.         (if (not (null? l))
  1855.           (let ((y (assq (car l) bins)))
  1856.             (set-cdr! y (- (cdr y) 1))
  1857.             (loop (cdr l))))))
  1858.  
  1859.     (define (find-max-payoff l thunk)
  1860.       (if (null? l)
  1861.         (thunk '() -1)
  1862.         (find-max-payoff (cdr l)
  1863.           (lambda (best-arg best-payoff)
  1864.             (let ((payoff (payoff-if-removed (car (car l)))))
  1865.               (if (>= payoff best-payoff)
  1866.                 (thunk (car l) payoff)
  1867.                 (thunk best-arg best-payoff)))))))
  1868.  
  1869.     (define (remove x l)
  1870.       (cond ((null? l)       '())
  1871.             ((eq? x (car l)) (cdr l))
  1872.             (else            (cons (car l) (remove x (cdr l))))))
  1873.               
  1874.     (for-each (lambda (x)
  1875.                 (for-each add-to-bin! (set->list (free-v (car x)))))
  1876.               l)
  1877.  
  1878.     (let loop ((args l) (ordered-args '()))
  1879.       (if (null? args)
  1880.         (reverse ordered-args)
  1881.         (find-max-payoff args
  1882.           (lambda (best-arg best-payoff)
  1883.             (remove-free-vars! (free-v (car best-arg)))
  1884.             (loop (remove best-arg args) (cons best-arg ordered-args))))))))
  1885.  
  1886. (define (args-live-vars live order)
  1887.   (cond ((null? order)
  1888.          live)
  1889.         ((eq? (car (car order)) 'return)
  1890.          (args-live-vars (set-adjoin live ret-var)
  1891.                          (cdr order)))
  1892.         (else
  1893.          (args-live-vars (set-union live (free-variables (car (car order))))
  1894.                          (cdr order)))))
  1895.  
  1896. (define (stk-live-vars live slots why)
  1897.   (cond ((null? slots)
  1898.          live)
  1899.         ((not (car slots))
  1900.          (stk-live-vars live
  1901.                         (cdr slots)
  1902.                         why))
  1903.         ((eq? (car slots) 'return)
  1904.          (stk-live-vars (if (eq? why 'tail) (set-adjoin live ret-var) live)
  1905.                         (cdr slots)
  1906.                         why))
  1907.         (else
  1908.          (stk-live-vars (set-union live (free-variables (car slots)))
  1909.                         (cdr slots)
  1910.                         why))))
  1911.  
  1912.  
  1913. ;------------------------------------------------------------------------------
  1914. ;
  1915. ; generate code for a 'let' or 'letrec'
  1916.  
  1917. (define (gen-let vars vals node live why)
  1918.   (let ((var-val-map (pair-up vars vals))
  1919.         (var-set (list->set vars))
  1920.         (all-live (set-union live
  1921.                              (free-variables node)
  1922.                              (apply set-union (map free-variables vals)))))
  1923.  
  1924.     (define (var->val var) (cdr (assq var var-val-map)))
  1925.  
  1926.     (define (proc-var? var) (prc? (var->val var)))
  1927.  
  1928.     (define (closed-vars var const-proc-vars)
  1929.       (set-difference (not-constant-closed-vars (var->val var))
  1930.                       const-proc-vars))
  1931.  
  1932.     (define (no-closed-vars? var const-proc-vars)
  1933.       (set-empty? (closed-vars var const-proc-vars)))
  1934.  
  1935.     (define (closed-vars? var const-proc-vars)
  1936.       (not (no-closed-vars? var const-proc-vars)))
  1937.  
  1938.     (define (compute-const-proc-vars proc-vars)
  1939.       (let loop1 ((const-proc-vars proc-vars))
  1940.         (let ((new-const-proc-vars
  1941.                 (set-keep (lambda (x) (no-closed-vars? x const-proc-vars))
  1942.                           const-proc-vars)))
  1943.           (if (not (set-equal? new-const-proc-vars const-proc-vars))
  1944.             (loop1 new-const-proc-vars)
  1945.             const-proc-vars))))
  1946.  
  1947.     (let* ((proc-vars (set-keep proc-var? var-set))
  1948.            (const-proc-vars (compute-const-proc-vars proc-vars))
  1949.            (clo-vars (set-keep (lambda (x) (closed-vars? x const-proc-vars))
  1950.                                proc-vars))
  1951.            (clo-vars-list (set->list clo-vars)))
  1952.  
  1953.       (for-each
  1954.         (lambda (proc-var)
  1955.           (let ((label (schedule-gen-proc (var->val proc-var) '())))
  1956.             (add-known-proc (lbl-num label) (var->val proc-var))
  1957.             (add-constant-var proc-var label)))
  1958.         (set->list const-proc-vars))
  1959.  
  1960.       (let ((non-clo-vars-list
  1961.               (set->list
  1962.                 (set-keep (lambda (var)
  1963.                             (and (not (set-member? var const-proc-vars))
  1964.                                  (not (set-member? var clo-vars))))
  1965.                           vars)))
  1966.             (liv (set-union live
  1967.                             (apply
  1968.                               set-union
  1969.                               (map (lambda (x) (closed-vars x const-proc-vars))
  1970.                                    clo-vars-list))
  1971.                             (free-variables node))))
  1972.  
  1973.         (let loop2 ((vars* non-clo-vars-list))
  1974.           (if (not (null? vars*))
  1975.             (let* ((var (car vars*))
  1976.                    (val (var->val var))
  1977.                    (needed (vals-live-vars liv
  1978.                              (map var->val (cdr vars*)))))
  1979.               (if (var-useless? var)
  1980.                 (gen-node val needed 'side)
  1981.                 (save-val (gen-node val needed 'need) var needed))
  1982.               (loop2 (cdr vars*)))))
  1983.  
  1984.         (if (pair? clo-vars-list)
  1985.           (begin
  1986.  
  1987.             (dealloc-slots
  1988.               (- nb-slots (stk-num (highest-live-slot liv))))
  1989.  
  1990.             (let loop3 ((l clo-vars-list))
  1991.               (if (not (null? l))
  1992.                 (begin
  1993.                   (push-slot)
  1994.                   (let ((var (car l))
  1995.                         (slot (make-stk nb-slots)))
  1996.                      (put-var slot var)
  1997.                      (loop3 (cdr l))))))
  1998.  
  1999.             (bb-put-non-branch! *bb*
  2000.               (make-MAKE_CLOSURES
  2001.                 (map (lambda (var)
  2002.                        (let ((closed-list
  2003.                                (set->list (closed-vars var const-proc-vars))))
  2004.                          (if (null? closed-list)
  2005.                            (compiler-internal-error
  2006.                              "gen-let, no closed variables:" (var-name var))
  2007.                            (make-closure-parms
  2008.                              (var->opnd var)
  2009.                              (lbl-num (schedule-gen-proc
  2010.                                         (var->val var)
  2011.                                         closed-list))
  2012.                              (map var->opnd closed-list)))))
  2013.                      clo-vars-list)
  2014.                 (current-frame live)
  2015.                 (source-comment node)))))
  2016.  
  2017.         (gen-node node live why)))))
  2018.  
  2019. (define (save-arg opnd var live)
  2020.   (if (glo? opnd)
  2021.     (add-constant-var var opnd)
  2022.     (save-val opnd var live)))
  2023.  
  2024. (define (save-val opnd var live)
  2025.   (cond ((or (obj? opnd) (lbl? opnd))
  2026.          (add-constant-var var opnd))
  2027.         ((and (reg? opnd)
  2028.               (not (set-member? (reg-num opnd) (live-regs live))))
  2029.          (put-var opnd var))
  2030.         ((and (stk? opnd)
  2031.               (not (set-member? (stk-num opnd) (live-slots live))))
  2032.          (put-var opnd var))
  2033.         (else
  2034.          (save-in-slot opnd var live))))
  2035.  
  2036. (define (save-in-slot opnd var live)
  2037.   (let ((slot (lowest-dead-slot live)))
  2038.     (put-copy opnd slot var live)))
  2039.  
  2040. (define (save-var opnd var live)
  2041.   (cond ((or (obj? opnd) (lbl? opnd))
  2042.          (add-constant-var var opnd)
  2043.          var)
  2044.         ((or (glo? opnd) (reg? opnd) (stk? opnd))
  2045.          (get-var opnd))
  2046.         (else
  2047.          (let ((dest (or (highest-dead-reg live) (lowest-dead-slot live))))
  2048.            (put-copy opnd dest var live)
  2049.            var))))
  2050.  
  2051. (define (put-copy opnd loc var live)
  2052.   (if (and (stk? loc) (> (stk-num loc) nb-slots)) (push-slot))
  2053.   (if var (put-var loc var))
  2054.   (if (not (eq? opnd loc))
  2055.     (bb-put-non-branch! *bb*
  2056.       (make-COPY opnd loc (current-frame (if var (set-adjoin live var) live)) #f))))
  2057.  
  2058. (define (var-useless? var)
  2059.   (and (set-empty? (var-refs var))
  2060.        (set-empty? (var-sets var))))
  2061.  
  2062. (define (vals-live-vars live vals)
  2063.   (if (null? vals)
  2064.     live
  2065.     (vals-live-vars (set-union live (free-variables (car vals)))
  2066.                     (cdr vals))))
  2067.  
  2068. ;------------------------------------------------------------------------------
  2069. ;
  2070. ; generate code for a future
  2071.  
  2072. (define (gen-fut node live why)
  2073.   (let* ((val (fut-val node))
  2074.          (clo-vars (not-constant-closed-vars val))
  2075.          (clo-vars-list (set->list clo-vars))
  2076.          (ret-var* (make-temp-var 0))
  2077.          (live-after live)
  2078.          (live-starting-task (set-adjoin (set-union live-after clo-vars)
  2079.                                          ret-var*))
  2080.          (task-lbl (bbs-new-lbl! *bbs*))
  2081.          (return-lbl (bbs-new-lbl! *bbs*)))
  2082.  
  2083.     ; save regs on stack if they contain values needed after the future
  2084.     (save-regs (live-regs live-after)
  2085.                live-starting-task)
  2086.  
  2087.     (let ((frame-start (stk-num (highest-live-slot live-after))))
  2088.  
  2089.       ; move return address to where task expects it
  2090.       (save-opnd-to-reg (make-lbl return-lbl)
  2091.                         target.task-return
  2092.                         ret-var*
  2093.                         (set-remove live-starting-task ret-var*))
  2094.  
  2095.       ; save variables that the task needs (that are not in regs)
  2096.       (let loop1 ((l clo-vars-list) (i 0))
  2097.         (if (null? l)
  2098.           (dealloc-slots (- nb-slots (+ frame-start i)))
  2099.           (let ((var (car l))
  2100.                 (rest (cdr l)))
  2101.             (if (memq var regs)
  2102.               (loop1 rest i)
  2103.               (let loop2 ((j (- target.nb-regs 1)))
  2104.                 (if (>= j 0)
  2105.                   (if (or (>= j (length regs))
  2106.                           (not (set-member? (list-ref regs j) live-starting-task)))
  2107.                     (let ((reg (make-reg j)))
  2108.                       (put-copy (var->opnd var) reg var live-starting-task)
  2109.                       (loop1 rest i))
  2110.                     (loop2 (- j 1)))
  2111.                 (let ((slot (make-stk (+ frame-start (+ i 1))))
  2112.                       (needed (list->set rest)))
  2113.                   (if (and (or (> (stk-num slot) nb-slots)
  2114.                                (not (memq (list-ref slots (- nb-slots (stk-num slot))) regs)))
  2115.                            (set-member? (stk-num slot) (live-slots needed)))
  2116.                     (save-opnd slot live-starting-task))
  2117.                   (put-copy (var->opnd var) slot var live-starting-task)
  2118.                   (loop1 rest (+ i 1)))))))))
  2119.  
  2120.       (seal-bb (intr-checks? (node-decl node)) 'CALL)
  2121.  
  2122.       (bb-put-branch! *bb*
  2123.         (make-JUMP (make-lbl task-lbl)
  2124.                    #f
  2125.                    #f
  2126.                    (current-frame live-starting-task)
  2127.                    (source-comment node)))
  2128.  
  2129.       (let ((method
  2130.               (futures-method (node-decl node)))
  2131.             (task-context
  2132.               (make-context (- nb-slots frame-start)
  2133.                             (reverse (nth-after (reverse slots) frame-start))
  2134.                             (cons ret-var (cdr regs))
  2135.                             '()
  2136.                             interrupt
  2137.                             entry-bb))
  2138.             (return-context
  2139.               (make-context frame-start
  2140.                             (nth-after slots (- nb-slots frame-start))
  2141.                             '()
  2142.                             closed
  2143.                             (return-interrupt interrupt)
  2144.                             entry-bb)))
  2145.  
  2146.         (restore-context task-context)
  2147.         (set! *bb* (make-bb
  2148.                      (make-LABEL-TASK
  2149.                        task-lbl
  2150.                        method
  2151.                        (current-frame live-starting-task)
  2152.                        (source-comment node))
  2153.                      *bbs*))
  2154.  
  2155.         (gen-node val ret-var-set 'tail)
  2156.  
  2157.         (let ((result-var (make-temp-var 'future)))
  2158.           (restore-context return-context)
  2159.           (put-var target.proc-result result-var)
  2160.  
  2161.           (set! *bb* (make-bb
  2162.                        (make-LABEL-RETURN
  2163.                          return-lbl
  2164.                          method
  2165.                          (current-frame (set-adjoin live result-var))
  2166.                          (source-comment node))
  2167.                        *bbs*))
  2168.  
  2169.           (gen-return target.proc-result why node))))))
  2170.  
  2171. ;------------------------------------------------------------------------------
  2172.